home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 4 / BBS in a Box - Macintosh - Volume IV (January 1992) (BBS in a Box).iso / Files / Prog / M / MCLUTILS.CPT / oodles-of-utils / mixin-madness / simple-view-mixins / selectable-svm.lisp / selectable-svm.lisp
Encoding:
Text File  |  1991-10-25  |  11.4 KB  |  315 lines  |  [TEXT/CCL2]
  1. (in-package :oou)
  2. (provide :selectable-svm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; selectable-svm.Lisp
  5. ;;
  6. ;; Copyright © 1991 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; mixins for selecting views
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :simple-view-ce)
  16.  
  17.  
  18. (export '(selectable-svm selectable-rb-svm selectable-cb-svm
  19.           selected-items
  20.           ))
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. #|
  24.  
  25. These mixins group views into clusters and handle selection of
  26. items within a cluster. 3 classes are defined, differing in how they handle
  27. multiple selections:
  28.  selectable-svm    - shift click to extend selections (à la the Finder)
  29.  selectable-rb-svm - no multiple selections (à la radio buttons)
  30.  selectable-cb-svm - click to toggle selections (à la check boxes)
  31.  
  32. See Also
  33.  draggable-svm - dragging current selection
  34.  droppable-svm - dragging + dropping selection onto targets
  35.  
  36.  
  37. Initargs
  38.  
  39.  :selection-cluster (nil)
  40.     The selection cluster to which the item belongs. (test with eq)
  41.     Members of a cluster are required to have the same containing view.
  42.     Multiple selection constraints are enforced within each cluster.
  43.  
  44.  :selected-p [nil]
  45.     Determines if the item initially selected.
  46.  
  47.  :all-drag-actions-p [t]
  48.     If the item is draggable, this determines if the drag actions of
  49.     all items in the selections will be called during the drag.
  50.  
  51.  :all-drag-end-actions-p [t]
  52.     If the item is draggable, this determines if the drag end actions of
  53.     all items in the selections will be called after the drag.
  54.  
  55.  :all-drop-actions-p [t]
  56.     If the item is droppable, this determines if the drop actions of
  57.     all items in the selections will be called after the drop.
  58.  
  59.  
  60. Methods of Interest
  61.  
  62.  selected-items (sv selectable-svm)
  63.    Returns a list of the items currently selected in di's cluster.
  64.    Use with setf to change the current selection.
  65.  
  66.  hilite-selected-item (sv selectable-svm) hilite-flag
  67.    Specialize this to customize the hiliting effect for selected items.
  68.    hilite-flag indicates whether to hilite or un-hilite the item (t/nil).
  69.    The default method uses inversion.
  70.  
  71. Note on combining selectable and draggable behavior:
  72. selectable-svm must appear BEFORE draggable-svm in the class precedence
  73. list (it specializes some of draggable-svm's methods). Keep this in mind
  74. when using selectable-svm with any items that inherit from draggable-svm
  75. like droppable-svm.
  76.  
  77. |#
  78. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79.  
  80. (defclass selectable-svm ()
  81.   ((selection-cluster      :initarg :selection-cluster
  82.                            :accessor selection-cluster)
  83.    (selected-p             :initarg :selected-p
  84.                            :accessor selected-p)
  85.    (all-drag-actions-p     :initarg :all-drag-actions-p
  86.                            :accessor all-drag-actions-p)
  87.    (all-drag-end-actions-p :initarg :all-drag-end-actions-p
  88.                            :accessor all-drag-end-actions-p)
  89.    (all-drop-actions-p     :initarg :all-drop-actions-p
  90.                            :accessor all-drop-actions-p))
  91.   (:default-initargs
  92.     :selection-cluster nil
  93.     :selected-p nil
  94.     :all-drag-actions-p t
  95.     :all-drag-end-actions-p t
  96.     :all-drop-actions-p t
  97.     ))
  98.  
  99. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  100. ;; click handling
  101.  
  102. (defmethod view-click-event-handler :before ((sv selectable-svm) where)
  103.   (declare (ignore where))
  104.   (with-focused-view (focusing-view sv)
  105.     (if (selected-p sv)
  106.       (click-selected-item sv (shift-key-p))
  107.       (click-unselected-item sv (shift-key-p)))))
  108.  
  109. (defmethod click-unselected-item ((sv selectable-svm) shift-p)
  110.   (unless shift-p (deselect-all sv :draw-now-p t))
  111.   (select-item sv :draw-now-p t))
  112.  
  113. (defmethod click-selected-item ((sv selectable-svm) shift-p)
  114.   (when shift-p (deselect-item sv :draw-now-p t)))
  115.  
  116. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  117. ;; drawing (hiliting)
  118.  
  119. (defmethod view-draw-contents :after ((sv selectable-svm))
  120.   (when (selected-p sv) (hilite-selected-item sv t)))
  121.  
  122. (defmethod hilite-selected-item ((sv selectable-svm) hilite-flag)
  123.   (with-focused-view (focusing-view sv)
  124.     (hilite-view sv hilite-flag)))
  125.  
  126. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  127. ;; handling the current selection
  128.  
  129. (defmethod mapc-selectable-cluster ((sv selectable-svm) fn &optional selected-only-p)
  130.   ;;search starts from the item's container
  131.   (with-slots (selection-cluster) sv
  132.     (flet ((map-fn (i) (when (and (eq (selection-cluster i) selection-cluster)
  133.                                   (or (selected-p i) (not selected-only-p)))
  134.                          (funcall fn i))))
  135.       (declare (dynamic-extent #'map-fn))
  136.       (map-subviews (view-container sv) #'map-fn 'selectable-svm))))
  137.                                
  138.  
  139. (defmethod selected-items ((sv selectable-svm))
  140.   "(sv selectable-svm)
  141. Returns a list of all the selected items in di's cluster"
  142.   (let ((item-list nil))
  143.     (flet ((fn (i) (push i item-list)))
  144.       (declare (dynamic-extent #'fn))
  145.       (mapc-selectable-cluster sv #'fn t)
  146.       (nreverse item-list))))
  147.  
  148. (defmethod (setf selected-items) (items (sv selectable-svm))
  149.   (without-interrupts
  150.    (deselect-all sv)
  151.    (dolist (i items) (select-item i))))
  152.  
  153. ;;;;;;;;;;
  154. ;;Note: the draw-now-p is provided for using these methods at
  155. ;;interrupt time (e.g. during click event handling). Normally you
  156. ;;should let draw-now-p default to nil. If you use a non-nil
  157. ;;draw-now-p, make sure the current view is focused to the item's
  158. ;;container.
  159.  
  160. (defmethod select-item ((sv selectable-svm) &key draw-now-p)
  161.   (unless (selected-p sv)
  162.     (setf (selected-p sv) t)
  163.     (if draw-now-p
  164.       (hilite-selected-item sv t)
  165.       (invalidate-view sv t))))
  166.  
  167. (defmethod deselect-item ((sv selectable-svm) &key draw-now-p)
  168.   (when (selected-p sv)
  169.     (setf (selected-p sv) nil)
  170.     (if draw-now-p
  171.       (hilite-selected-item sv nil)
  172.       (invalidate-view sv t))))
  173.  
  174. (defmethod deselect-all ((sv selectable-svm) &key draw-now-p)
  175.   (flet ((fn (i) (deselect-item i :draw-now-p draw-now-p)))
  176.     (declare (dynamic-extent #'fn))
  177.     (mapc-selectable-cluster sv #'fn t)))
  178.  
  179. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  180. ;;specializations for handling dragging selections
  181.  
  182. (declaim (ftype (function (&rest t) t)
  183.                 drop-action
  184.                 drag-action
  185.                 drag-end-action
  186.                 set-drag-outline-rgn))
  187.  
  188. (defmethod set-DragGrayRgn-areas :after ((sv selectable-svm) where drag-rgn limitRect slopRect)
  189.   ;;specialize the drag-rgn to be the union of all selected items
  190.   (declare (ignore where limitRect slopRect))
  191.   (with-macptrs ((temp-rgn (#_NewRgn)))
  192.     (flet ((add-rgn (i)
  193.              (set-drag-outline-rgn i temp-rgn)
  194.              (#_UnionRgn temp-rgn drag-rgn drag-rgn)))
  195.       (declare (dynamic-extent #'add-rgn))
  196.       (mapc-selectable-cluster sv #'add-rgn t))
  197.     (#_DisposeRgn temp-rgn)))
  198.  
  199. (defmethod draggable-p ((sv selectable-svm))
  200.   ;;Must check if the item is selected before allowing dragging. Normally this
  201.   ;;isn't needed cause the click selects the item, but a shift-click can de-select.
  202.   (and (selected-p sv) (call-next-method)))
  203.  
  204. (defmethod pre-drag-hilite ((sv selectable-svm) hilite-flag)
  205.   ;;selectable items already hilite when clicked - so do nothing
  206.   (declare (ignore sv hilite-flag)))
  207.  
  208. (defmethod drag-item ((sv selectable-svm) where)
  209.   ;;*current-drag-selection* is bound for the duration of the drag, 
  210.   ;;so droppable-p won't have to repeatedly compute the current selection.
  211.   (declare (ignore where))
  212.   (let ((*current-drag-selection* (selected-items sv)))
  213.     (declare (special *current-drag-selection*))
  214.     (call-next-method)))
  215.  
  216. (defmethod droppable-p ((sv selectable-svm) (target simple-view))
  217.   ;;disallow dropping on any member of current selection
  218.   (declare (special *current-drag-selection*))
  219.   (unless (find target *current-drag-selection*)
  220.     (call-next-method)))
  221.  
  222. ;;;;;;;;;;
  223. ;;3 call action functions specialized to use entire selection
  224.  
  225. (defmethod call-drag-action ((sv selectable-svm))
  226.   (declare (special *current-drag-selection*))
  227.     (if (slot-value sv 'all-drag-actions-p)
  228.       (dolist (i *current-drag-selection*) (drag-action i))
  229.       (drag-action sv)))
  230.  
  231. (defmethod call-drag-end-action ((sv selectable-svm) drag-offset dest-point)
  232.   (if (slot-value sv 'all-drag-end-actions-p)
  233.     (flet ((fn (i) (drag-end-action i drag-offset dest-point)))
  234.       (declare (dynamic-extent #'fn))
  235.       (mapc-selectable-cluster sv #'fn t))
  236.     (drag-end-action sv drag-offset dest-point)))
  237.  
  238. (defmethod call-drop-action ((sv selectable-svm) (target simple-view) drag-offset dest-point)
  239.   (if (slot-value sv 'all-drag-end-actions-p)
  240.     (flet ((fn (i) (drop-action i target drag-offset dest-point)))
  241.       (declare (dynamic-extent #'fn))
  242.       (mapc-selectable-cluster sv #'fn t))
  243.     (drop-action sv target drag-offset dest-point)))
  244.  
  245.  
  246. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  247. ;; selectable views with radio button behavior
  248.  
  249. (defclass selectable-rb-svm (selectable-svm) ())
  250.  
  251. (defmethod click-unselected-item ((sv selectable-rb-svm) shift-p)
  252.   (declare (ignore shift-p))
  253.   (deselect-all sv :draw-now-p t)
  254.   (select-item sv :draw-now-p t))
  255.  
  256. (defmethod click-selected-item ((sv selectable-rb-svm) shift-p)
  257.   (declare (ignore sv shift-p)))
  258.  
  259.  
  260. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  261. ;; selectable views with check box behavior
  262.  
  263. (defclass selectable-cb-svm (selectable-svm) ())
  264.  
  265. (defmethod click-unselected-item ((sv selectable-cb-svm) shift-p)
  266.   (declare (ignore shift-p))
  267.   (select-item sv :draw-now-p t))
  268.  
  269. (defmethod click-selected-item ((sv selectable-cb-svm) shift-p)
  270.   (declare (ignore shift-p))
  271.   (deselect-item sv :draw-now-p t))
  272.  
  273. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  274.  
  275. #|
  276.  
  277. ;;; a modest example - adding select behavior to static text dialog items
  278.  
  279. (defclass stsel (selectable-svm static-text-dialog-item) ())
  280. ;(defclass stsel (selectable-rb-svm static-text-dialog-item) ())
  281. ;(defclass stsel (selectable-cb-svm static-text-dialog-item) ())
  282.  
  283. (setf *test-w*
  284.       (make-instance 'dialog
  285.                      :window-type :document
  286.                      :view-position :centered
  287.                      :view-size #@(200 100)
  288.                      :window-title "selectable-svm demo"
  289.                      :close-box-p t
  290.                      :color-p t
  291.                      :view-subviews
  292.                      (list (make-instance 'stsel
  293.                                              :view-position #@(20 20)
  294.                                              :dialog-item-text "item 1"
  295.                                              :view-nick-name :i1
  296.                                              :selection-cluster 1
  297.                                              )
  298.                            (make-instance 'stsel
  299.                                              :view-position #@(20 40)
  300.                                              :dialog-item-text "item 2"
  301.                                              :view-nick-name :i2
  302.                                              :selection-cluster 1
  303.                                              )
  304.                            (make-instance 'stsel
  305.                                              :view-position #@(20 60)
  306.                                              :dialog-item-text "Item 3"
  307.                                              :view-nick-name :i2
  308.                                              :selection-cluster 1
  309.                                              )
  310.  
  311.                            )))
  312.  
  313. ;(selected-items (view-named :i1 *test-w*))
  314.  
  315. |#